Power Programmierung

home *** CD-ROM | disk | FTP | other *** search

/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / drdobbs / 1987 / 11 / breeden.lst next >

Wrap

File List | 1987-10-08 | 35KB | 685 lines

Listing 1 Screen # 0 \ jbb 15:47 08/04/87 GETIMAGE Copyright 1987, All Rights Reserved by J. Brooks Breeden Columbus, Ohio August 4, 1987 Loads an EGAPAINT file into video memory from within UR/FORTH for subsequent animation, etc. Screen # 1 \ Misc. jbb 13:01 08/04/87 DOSINT \ fetch level 2 DOS interface HCB IMAGEHCB \ create the handle block CREATE PALTAB 16 ALLOT \ to hold egapaint's palette : ?MEMREQ ( x1 y1 x2 y2 - bytes) \ calc. memory req to @BLOCK ROT - 1+ -ROT SWAP - 1+ 2/ 1+ * 4 + ; HEX : RESTORE-EGA ( - ) \ restore EGA's default mode: 2 3C4 PC! 0F 3C5 PC! \ default map mask 3 3CE PC! 0 3CF PC! \ default data rotate reg value 5 3CE PC! 0 3CF PC! \ default write mode 0 8 3CE PC! FF 3CF PC! ; \ default bit mask DECIMAL --> Screen # 2 \ EGA map mask control jbb 15:37 08/04/87 HEX : READMODE0 ( - ) 5 3CE PC! 8 3CF PC! 2 3CE PC! 0 3CF PC! ; \ set map-masks to select active EGA color bit-planes : BLUEPLANE ( - ) 2 3C4 PC! 1 3C5 PC! ; \ plane 0 : GREENPLANE ( - ) 2 3C4 PC! 2 3C5 PC! ; \ plane 1 : REDPLANE ( - ) 2 3C4 PC! 4 3C5 PC! ; \ plane 2 : INTENSEPLANE ( - ) 2 3C4 PC! 8 3C5 PC! ; \ plane 3 DECIMAL --> Screen # 3 \ File control jbb 12:59 08/04/87 : OPENIMAGEFILE ( ^filename - ) IMAGEHCB NAME>HCB \ force filename IMAGEHCB O_RD FOPEN \ open file for reading IF ABORT" Can't open file." THEN ; : CLOSEIMAGEFILE ( - ) IMAGEHCB FCLOSE DROP ; : MAKEIMAGEFILE ( ^filename - ) IMAGEHCB NAME>HCB \ force filename IMAGEHCB 0 FMAKE \ make "normal" file IF ABORT" Can't make file." THEN ; --> Screen # 4 \ Read EGAPAINT file from disk to video jbb 15:45 08/04/87 \ To load EGAPAINT disk image into EGA video segment... \ set map mask, read bytes from disk, repeat for each plane : READBYTES ( - ) \ read 28,000 bytes to video segment IMAGEHCB ?VSEG 0 \ source=handle; dest.= videoseg:offset 28000 FREADL \ read 28,000 bytes DROP ; \ drop flag. : READPAINTFILE ( - ) \ read all four planes in sequence... BLUEPLANE READBYTES REDPLANE READBYTES GREENPLANE READBYTES INTENSEPLANE READBYTES ; --> Screen # 5 \ jbb 15:44 08/04/87 : LOADPAINTFILE ( ^filename - ) 640X350 VMODE CLS \ hi-res 16-color OPENIMAGEFILE \ Open the file, and IMAGEHCB PALTAB 16 FREAD \ read palette data. IF PALTAB !PALETTE \ If read was successful, THEN \ set palette to new colors. READMODE0 \ Set read mode 0 and READPAINTFILE \ read the bit-plane data. CLOSEIMAGEFILE \ Close the file, and RESTORE-EGA ; \ restore the EGA defaults. --> Screen # 6 \ Load the EGAPAINT full-screen image jbb 15:17 08/04/87 CREATE BARON ,C" THEFOKKR.IMG" \ orig 112K EGAPAINT disk file CREATE FOKKER ,C" DERFOKKR.IMG" \ new smaller @BLOCK disk file CREATE DR.1 3072 ALLOT \ memory req as multiple of 8 : SAVEDR.1 1 1 106 53 DR.1 @BLOCK ; \ get block to memory : GETIMAGE BARON LOADPAINTFILE SAVEDR.1 ; \ get orig image>mem : SAVEFOKKER FOKKER MAKEIMAGEFILE \ build .img file on disk IMAGEHCB PALTAB 16 FWRITE DROP \ include pallete info IMAGEHCB DR.1 2904 FWRITE DROP \ write DR.1 mem to disk CLOSEIMAGEFILE ; \ close it out... --> Screen # 7 \ CHECKOUT JUNK jbb 16:07 08/04/87 : CK1 HR DR.1 267 148 !BLOCK 277 156 361 192 FRAME \ Fokker image limits LTBLUE FG 267 148 372 200 FRAME \ image area saved 262 143 272 153 FRAME \ hit zone around CORNER 314 165 324 175 FRAME ; \ hit zone on Fokker : GUNSIGHT ( - ) ORANGE FG 269 170 369 170 LINE 319 133 319 274 LINE 319 170 50 circle ; : CK CK1 GUNSIGHT ; Listing 2 Listing 2. Pseudocode to move a full 112,000 byte image from the disk to the screen: NOTE: ALL NUMBERS HEXIDECIMAL Set the video mode to graphics mode xx however your language does it. Open the file using a DOS handle however your language does it. If palette data is the first data in the file, Then read the palette data and set the new palette. (This should be covered in your language's high level routines.) Set read mode 0 Write 5 to port 3CE, then write 8 to port 3CF, then write 2 to port 3CE, then write 0 to port 3CF. Set map mask to plane 0 (blue plane) Write 2 to port 3C4, then write 1 to port 3C5. Read 28,000 bytes from the file to A000:0000 however your language does it. Set map mask to plane 2 (red plane) Write 2 to port 3C4, then write 4 to port 3C5. Read 28,000 bytes from the file to A000:0000 however your language does it. Set map mask to plane 1 (green plane) Write 2 to port 3C4, then write 4 to port 3C5. Read 28,000 bytes from the file to A000:0000 however your language does it. Set map mask to plane 3 (intensity plane) Write 2 to port 3C4, then write 8 to port 3C5. Read 28,000 bytes from the file to A000:0000 however your language does it. Close the file, however your language does it. Restore EGA default values. (set map mask default: all planes active) Write 2 to port 3C4, then write 0F to port 3C5. (set data rotate register default) Write 3 to port 3CE, then write 0 to port 3CF. (set default write mode 0) Write 5 to port 3CE, then write 0 to port 3CF. (set default bit-mask) Write 8 to port 3CE, then write FF to port 3CF. Listing 3 Screen # 0 \ jbb 17:28 07/04/87 FOKKER.SCR A Mindless Game of Motor Skill (somewhere over the trenches...) NOTE: YOU ABSOLUTELY MUST HAVE CRUISE CONTROL, OR SOME OTHER KIND OF KEYBOARD SPEEDUP SOFTWARE FOR THIS TO WORK !!! Standard Version Copyright (C) 1987, All Rights Reserved by J. Brooks Breeden EGAGRAPH.EXE must be loaded first Screen # 1 \ File control... jbb 13:08 08/04/87 \ this screen is required to load image initially. \ For turnkey, the image is in memory & this scr isn't required DOSINT \ level 2 DOS interface HCB IMAGEHCB \ create the handle block : OPENIMAGEFILE ( ^filename - ) IMAGEHCB NAME>HCB \ force filename IMAGEHCB O_RD FOPEN \ open file for reading IF ABORT" Can't open file." THEN ; : CLOSEIMAGEFILE ( -- ) IMAGEHCB FCLOSE DROP ; \ close, ignore status --> Screen # 2 \ File control... jbb 09:49 08/01/87 CREATE DR.1 3000 ALLOT \ to hold the bit map image CREATE PALTAB 16 ALLOT \ new palette of colors CREATE FOKKERIMG ,C" DERFOKKR.IMG" \ name of the image file : GETFOKKER \ load binary image from disk to memory DR.1 3000 ERASE \ clean out memory area FOKKERIMG OPENIMAGEFILE \ open 'er up IMAGEHCB PALTAB 16 FREAD DROP \ read in palette info IMAGEHCB DR.1 2866 FREAD DROP \ read in the image CLOSEIMAGEFILE ; \ close the file GETFOKKER \ load the Fokker image during the compile... --> \ Note: Obviously, you'd better have the image \ file in your directory at this point! Screen # 3 \ Pallette colors jbb 17:10 08/02/87 : FG FOREGROUND ; \ shorthand for LMI's words : BG BACKGROUND ; : HR 640X350 VMODE ; \ high res EGA 16-color mode \ Named colors for the EGAPAINT default pallette 0 CONSTANT BLACK 8 CONSTANT GREEN 1 CONSTANT DKGRAY 9 CONSTANT LTGREEN 2 CONSTANT GRAY 10 CONSTANT CYAN 3 CONSTANT DKRED 11 CONSTANT LTBLUE 4 CONSTANT RED 12 CONSTANT BLUE 5 CONSTANT ORANGE 13 CONSTANT DKBLUE 6 CONSTANT YELLOW 14 CONSTANT PURPLE 7 CONSTANT DKGREEN 15 CONSTANT WHITE --> Screen # 4 \ Utilities jbb 09:53 08/01/87 : TAB ( row col - ) SWAP GOTOXY ; \ clearer for text : ? @ . ; \ returns unique IBM keycode for each keypress : MYKEY ( - n) KEY DUP 0= IF DROP KEY 128 + THEN ; : WAIT ( - ) MYKEY DROP ; \ wait for a keypress \ vector math... : V+ ( a b c d --- a+c b+d) >R ROT + SWAP R> + ; : V* ( a b c d --- a*c b*d) >R ROT * SWAP R> * ; \ not used; : V/ ( a b c d --- a/c b/d) >R ROT / SWAP R> / ; \ for info.. : S-LINE ( row - ) 0 TAB 80 0 DO 196 EMIT LOOP ; \ a line : D-LINE ( row - ) 0 TAB 80 0 DO 205 EMIT LOOP ; \ dbl. line --> Screen # 5 \ Random number generator jbb 09:56 08/01/87 VARIABLE SEED @TIME COMBINE SEED ! \ plant seed w/system clock : random ( - n ) \ 0 <= n <= 32767 SEED @ 259 * 3 + 32767 AND DUP SEED ! ; : RANDOM ( n1 - n2 ) \ 0 <= n2 < n1 random M* 32768 UM/MOD NIP ; : BETWEEN ( lo# hi# - inbetween#) OVER - RANDOM + ; : WITHIN? ( n hi# lo# - flag) >R 1- OVER < SWAP R> < AND ; --> Screen # 6 \ Fokker movement jbb 14:44 08/06/87 2VARIABLE CORNER \ xy-coords of up-left corner of fokker box -1 1 2EQU RANGE \ range of random fokker movement \ add to Baron's excitement by bumping allowed RANGE : EXCITEMENT ( - ) RANGE -1 1 V+ 2EQU RANGE ; \ leaves random x and y within RANGE by which to move Fokker : MOVEFOKKER ( - n n) RANGE BETWEEN RANGE BETWEEN ; : GUNSIGHT ( - ) ORANGE FG 269 170 369 170 LINE 319 133 319 274 LINE 319 170 50 circle ; --> Screen # 7 \ Stick control jbb 10:05 08/01/87 \ set gunsight movement based on #key pressed : ?stick ( adr - adr n n) MYKEY CASE 199 OF 2 -2 ENDOF 200 OF 0 -2 ENDOF 201 OF -2 -2 ENDOF 205 OF -2 0 ENDOF 209 OF -2 2 ENDOF 208 OF 0 2 ENDOF 207 OF 2 2 ENDOF 203 OF 2 0 ENDOF ( otherwise) 0 0 \ leave 0's for V+ to add... ROT \ move index to top of stack ENDCASE ; \ for ENDCASE to drop... : ?STICK ( adr - adr n n) ?TERMINAL \ key pressed? IF ?stick \ check stick control ELSE 0 0 THEN ; \ leave zeros for "V+" --> Screen # 8 \ Exclamations! jbb 10:12 08/01/87 \ These aren't real serious curses; you make up your own! CREATE CURSES ," Dankeschoen! Welkommen! Wie Geh ts? Was ist das? Weiner Schnitzel! Bratwurst! Sauerbrauten! Knockwurst! Sauerkraut! Weisswurst " : EXCLAMATION \ shout a curse at the user, for distraction 3 30 TAB CLREOL 3 33 TAB ORANGE FG 10 RANDOM 20 * CURSES + 20 -TRAILING TYPE ; --> Screen # 9 \ Damage report jbb 10:14 08/01/87 VARIABLE #HITS \ # of hits in cockpit zone VARIABLE AMMO \ rounds of ammunition left : .HITS GRAY FG 22 44 TAB #HITS ? ; \ print out number of : .AMMO GRAY FG 23 44 TAB AMMO ? ; \ hits & ammo left. : HIT? CORNER 2@ 143 153 WITHIN? \ y in hit zone? SWAP 262 272 WITHIN? AND \ x in hit zone? Both? IF 2 #HITS +! .HITS \ Increment hits & show #. #HITS @ 4 MOD 0= \ For every 4 hits, increase IF EXCITEMENT EXCLAMATION \ movement & display curse! THEN THEN ; --> Screen # 10 \ Shooting... jbb 10:19 08/01/87 : 2SHOTS 219 349 319 170 LINE 419 349 320 170 LINE ; : FIREGUNS \ fire two shots, decrement ammo, show ammo left WHITE FG 2SHOTS 5000 0 DO LOOP \ kill some time DKBLUE FG 2SHOTS -2 AMMO +! .AMMO ; : SHOOTING? ?TERMINAL \ If there is keyboard input... IF MYKEY 32 = \ was it the spacebar? IF AMMO @ \ Yes, if we have any ammo, IF FIREGUNS HIT? THEN \ shoot & check if we hit the THEN \ Fokker. THEN ; --> Screen # 11 \ Explosion jbb 15:01 08/04/87 : BURST 320 0 \ random dots expanding in all four quadrants DO 319 I RANDOM + 174 I RANDOM - !PEL 319 I RANDOM + 174 I RANDOM + !PEL 319 I RANDOM - 174 I RANDOM + !PEL 319 I RANDOM - 174 I RANDOM - !PEL LOOP ; : EXPLODE 3 0 DO BURST LOOP ; \ it pulses the bursts... HEX \ clear bios buffer of waiting keypresses : CLR-KEY-BUF 0C01 regAX ! 21 INT86 ; DECIMAL : WAIT-FOR-ESC CLR-KEY-BUF BEGIN MYKEY 27 = UNTIL ; --> Screen # 12 \ Win message jbb 17:35 07/04/87 : WIN \ what happens if you shoot him down! WHITE FG EXPLODE DKBLUE FG REVERSE ORANGE FG 6 14 TAB ." What a pilot! You downed the baron with " 100 AMMO @ - . ." rounds. " 7 14 TAB ." Now it's time to head for home and celebrate. " 20 25 TAB ." Press ESC to go home in GLORY. " GRAY FG REVERSE WAIT-FOR-ESC ; --> Screen # 13 \ Lose message jbb 10:20 08/01/87 : LOSE \ what happens if you DON'T shoot him down... DKBLUE FG REVERSE ORANGE FG 6 14 TAB ." You are a rotten pilot! You waste ammunition, and " 7 14 TAB ." let yourself get outflown by the bloody Red Baron. " 8 14 TAB ." Tuck your tail beween your legs and head for home. " 20 23 TAB ." Now press ESC to go home in SHAME! " DKBLUE FG REVERSE GRAY FG WAIT-FOR-ESC ; --> Screen # 14 \ Setup jbb 10:22 08/01/87 F: FOKKER \ forward reference : SETUP HR PALTAB !PALETTE CLS \ use EGAPaint palette DKBLUE BG GUNSIGHT \ paint sky and gunsight -1 1 2EQU RANGE \ fokker motion range 175 375 BETWEEN 104 254 BETWEEN \ random starting points CORNER 2! 0 #HITS ! 100 AMMO ! \ setup the variables GRAY FG 22 34 TAB ." # OF HITS: " .HITS \ show hits 23 34 TAB ." AMMO LEFT: " .AMMO ; \ show ammo --> Screen # 15 \ Major loop jbb 10:23 08/01/87 : DOGFIGHT SETUP \ get ready... BEGIN DR.1 \ address of fokker bitmap CORNER 2@ MOVEFOKKER V+ \ +random movement ?STICK V+ ( --- adr x y) \ +stick control 2DUP CORNER 2! !BLOCK \ update corner; show plane SHOOTING? #HITS @ 19 > \ check hits in pilot zone IF WIN EXIT THEN \ blow up plane; you win. AMMO @ 0= \ out of ammo? IF LOSE EXIT THEN \ you lose... GUNSIGHT \ redisplay gunsight AGAIN ; --> Screen # 16 \ Options jbb 10:23 08/01/87 : D-LINES B/W CLS PURPLE FG 7 D-LINE 19 D-LINE RED FG ; \ double lines : .OPTIONS D-LINES 6 0 TAB ." Fokker" 6 36 TAB ." OPTIONS" LTBLUE FG 11 31 TAB ." F1. " GRAY FG ." Instructions" LTBLUE FG 13 31 TAB ." F2. " GRAY FG ." Play" LTBLUE FG 15 31 TAB ." F10. " GRAY FG ." Exit" 20 0 TAB ; --> Screen # 17 \ Credits jbb 13:25 07/31/87 : .CREDITS D-LINES 6 36 TAB ." FOKKER" LTBLUE FG 8 23 TAB ." (A Mindless Game of Motor Skill)" 11 20 TAB RED FG ." Somewhere over the trenches in France..." GRAY FG 14 22 TAB ." Copyright 1987, All Rights Reserved" 15 38 TAB ." by " 16 32 TAB ." J. Brooks Breeden" 17 32 TAB ." Columbus, Ohio" ORANGE FG 20 26 TAB ." Press Any Key to Continue..." 23 11 TAB LTBLUE FG ." Written in UR/FORTH from Laboratory Microsystems, Inc." 24 9 TAB ." Fokker Dr.1 created with EGAPAINT from RIX Softworks, Inc." ; --> Screen # 18 \ Help... jbb 13:24 07/31/87 : HELP1 B/W CLS RED FG 1 20 TAB ." Your Mission:" PURPLE FG 2 S-LINE LTBLUE FG 3 20 TAB ." Your mission is to down the Red Baron with 20 hits" 4 20 TAB ." in the cockpit area of his Fokker Dr.1 triplane." 5 20 TAB ." When you shoot, the Baron gets excited, and takes" 6 20 TAB ." evasive action. You have 100 rounds of ammo left," 7 20 TAB ." and your guns have a tendency to jam..." ; --> Screen # 19 \ Help... jbb 13:21 07/31/87 : HELP2 RED FG 9 20 TAB ." To play..." PURPLE FG 10 S-LINE LTBLUE FG 11 20 TAB ." The cursor keys control the gunsight like a joystick." 12 20 TAB ." The up arrow key pushes the stick forward. The down" 13 20 TAB ." arrow key pulls back on the stick. Left, right, and" 14 20 TAB ." diagonal keys move the stick as you would expect." 16 20 TAB ." Fire by holding down the space bar." 21 20 TAB ." Press Ctrl-Break to quit at any time." ; --> Screen # 20 \ Warning... jbb 10:24 08/01/87 : WARNING D-LINES 6 34 TAB ." WARNING!!!" LTBLUE FG 9 20 TAB ." YOU ABSOLUTELY MUST HAVE CRUISE CONTROL," 10 20 TAB ." QUICKEYS, OR OTHER TSR KEYBOARD SPEED-UP" 11 20 TAB ." RESIDENT IN ORDER TO RUN THIS PROGRAM !!!" 13 20 TAB ." If you do not have a keyboard speed-up" 14 20 TAB ." program resident, press Ctrl-Break to exit." 16 20 TAB ." If a keyboard speed-up program is resident..." ORANGE FG 20 26 TAB ." Press Any Key to Continue..." WAIT ; : .HELP HELP1 HELP2 ORANGE FG 23 26 TAB ." Press Any Key to Continue..." WAIT FOKKER ; --> Screen # 21 \ Main resolved jbb 10:24 08/01/87 : INTRO CLS B/W .CREDITS WAIT 20 0 TAB CLREOL ; R: FOKKER .OPTIONS MYKEY \ resolve FOKKER forward reference CASE 187 OF .HELP FOKKER ENDOF \ show instructions 188 OF DOGFIGHT FOKKER ENDOF \ do the dogfight 196 OF BYE ENDOF \ exit to DOS DROP FOKKER \ recurse to options ENDCASE ; : MAIN HR PALTAB !PALETTE WARNING INTRO FOKKER ;